home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-dup.el.z / gnus-dup.el
Encoding:
Text File  |  1998-05-21  |  5.0 KB  |  161 lines
  1. ;;; gnus-dup.el --- suppression of duplicate articles in Gnus
  2. ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.     See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;; This package tries to mark articles as read the second time the
  27. ;; user reads a copy.  This is useful if the server doesn't support
  28. ;; Xref properly, or if the user reads the same group from several
  29. ;; servers.
  30.  
  31. ;;; Code:
  32.  
  33. (eval-when-compile (require 'cl))
  34.  
  35. (require 'gnus)
  36. (require 'gnus-art)
  37.  
  38. (defgroup gnus-duplicate nil
  39.   "Suppression of duplicate articles."
  40.   :group 'gnus)
  41.  
  42. (defcustom gnus-save-duplicate-list nil
  43.   "*If non-nil, save the duplicate list when shutting down Gnus.
  44. If nil, duplicate suppression will only work on duplicates
  45. seen in the same session."
  46.   :group 'gnus-duplicate
  47.   :type 'boolean)
  48.  
  49. (defcustom gnus-duplicate-list-length 10000
  50.   "*The number of Message-IDs to keep in the duplicate suppression list."
  51.   :group 'gnus-duplicate
  52.   :type 'integer)
  53.  
  54. (defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression")
  55.   "*The name of the file to store the duplicate suppression list."
  56.   :group 'gnus-duplicate
  57.   :type 'file)
  58.  
  59. ;;; Internal variables
  60.  
  61. (defvar gnus-dup-list nil)
  62. (defvar gnus-dup-hashtb nil)
  63.  
  64. (defvar gnus-dup-list-dirty nil)
  65.  
  66. ;;;
  67. ;;; Starting and stopping
  68. ;;;
  69.  
  70. (gnus-add-shutdown 'gnus-dup-close 'gnus)
  71.  
  72. (defun gnus-dup-close ()
  73.   "Possibly save the duplicate suppression list and shut down the subsystem."
  74.   (gnus-dup-save)
  75.   (setq gnus-dup-list nil
  76.     gnus-dup-hashtb nil
  77.     gnus-dup-list-dirty nil))
  78.  
  79. (defun gnus-dup-open ()
  80.   "Possibly read the duplicate suppression list and start the subsystem."
  81.   (if gnus-save-duplicate-list
  82.       (gnus-dup-read)
  83.     (setq gnus-dup-list nil))
  84.   (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
  85.   ;; Enter all Message-IDs into the hash table.
  86.   (let ((list gnus-dup-list)
  87.     (obarray gnus-dup-hashtb))
  88.     (while list
  89.       (intern (pop list)))))
  90.  
  91. (defun gnus-dup-read ()
  92.   "Read the duplicate suppression list."
  93.   (setq gnus-dup-list nil)
  94.   (when (file-exists-p gnus-duplicate-file)
  95.     (load gnus-duplicate-file t t t)))
  96.  
  97. (defun gnus-dup-save ()
  98.   "Save the duplicate suppression list."
  99.   (when (and gnus-save-duplicate-list
  100.          gnus-dup-list-dirty)
  101.     (nnheader-temp-write gnus-duplicate-file
  102.       (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list))))
  103.   (setq gnus-dup-list-dirty nil))
  104.  
  105. ;;;
  106. ;;; Interface functions
  107. ;;;
  108.  
  109. (defun gnus-dup-enter-articles ()
  110.   "Enter articles from the current group for future duplicate suppression."
  111.   (unless gnus-dup-list
  112.     (gnus-dup-open))
  113.   (setq gnus-dup-list-dirty t)        ; mark list for saving
  114.   (let ((data gnus-newsgroup-data)
  115.      datum msgid)
  116.     ;; Enter the Message-IDs of all read articles into the list
  117.     ;; and hash table.
  118.     (while (setq datum (pop data))
  119.       (when (and (not (gnus-data-pseudo-p datum))
  120.          (> (gnus-data-number datum) 0)
  121.          (gnus-data-read-p datum)
  122.          (not (= (gnus-data-mark datum) gnus-canceled-mark))
  123.           (setq msgid (mail-header-id (gnus-data-header datum)))
  124.           (not (nnheader-fake-message-id-p msgid))
  125.           (not (intern-soft msgid gnus-dup-hashtb)))
  126.     (push msgid gnus-dup-list)
  127.      (intern msgid gnus-dup-hashtb))))
  128.   ;; Chop off excess Message-IDs from the list.
  129.   (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
  130.     (when end
  131.       (setcdr end nil))))
  132.  
  133. (defun gnus-dup-suppress-articles ()
  134.   "Mark duplicate articles as read."
  135.   (unless gnus-dup-list
  136.     (gnus-dup-open))
  137.   (gnus-message 6 "Suppressing duplicates...")
  138.   (let ((headers gnus-newsgroup-headers)
  139.     number header)
  140.     (while (setq header (pop headers))
  141.       (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
  142.          (gnus-summary-article-unread-p (mail-header-number header)))
  143.     (setq gnus-newsgroup-unreads
  144.           (delq (setq number (mail-header-number header))
  145.             gnus-newsgroup-unreads))
  146.     (push (cons number gnus-duplicate-mark)
  147.           gnus-newsgroup-reads))))
  148.   (gnus-message 6 "Suppressing duplicates...done"))
  149.  
  150. (defun gnus-dup-unsuppress-article (article)
  151.   "Stop suppression of ARTICLE."
  152.   (let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
  153.     (when id
  154.       (setq gnus-dup-list-dirty t)
  155.       (setq gnus-dup-list (delete id gnus-dup-list))
  156.       (unintern id gnus-dup-hashtb))))
  157.  
  158. (provide 'gnus-dup)
  159.  
  160. ;;; gnus-dup.el ends here
  161.